﻿module Violations

open System
open System.Collections.Concurrent
open System.Net
open System.Text.RegularExpressions
open System.Threading
open System.Windows
open System.Windows.Controls
open System.Xml.Linq

[<AutoOpenAttribute>]
module Types =

    /// Violation level.
    type ViolationLevel =
        | Error
        | Warning
        override x.ToString() = match x with
                                | Error -> "Error"
                                | Warning -> "Warning"

    /// Violation record.
    type Violation =
        {
            Code : string
            Level : ViolationLevel
            Title : string
            Index : int option
            Description : string
            Recommendation : string
        }

    /// Markup violation record (HTML validation).
    type MarkupViolation =
        {
            Level : string
            Line : string
            Col : string
            Message : string
        }
    
    /// Broken link record (broken links checking).
    type BrokenLink =
        {
            Status : string
            Link : string
        }

    type Message =
        | Url of string option
        | BLink of BrokenLink
        | Done
        | Stop
        | Mailbox of MailboxProcessor<Message>

module private Helpers =
    
    // Gate the numbers of broken link checking agents.
    [<Literal>]
    let Gate = 5

    // Displays broken links.
    let displayBrokenLinks (arr : BrokenLink []) =
        let wnd = Window()
        let dg = DataGrid()
        wnd.Title <- "Broken Links"
        wnd.Width <- 600.
        wnd.Height <- 600.
        dg.ItemsSource <- arr
        wnd.Content <- dg
        wnd.Show()
    
    // Returns the HTTP status code of a URL.
    let getStatus (url : string) =
        try
            try
                let req = WebRequest.Create(url) :?> HttpWebRequest
                req.UserAgent <- "Mozilla/5.0 (Windows; U; MSIE 9.0; Windows NT 9.0; en-US)"
                req.Timeout <- 3800
                let resp = req.GetResponse() :?> HttpWebResponse
                let code = resp.StatusCode
                Some (int code, string code)
            with
            | :? System.Net.WebException as ex -> let res = ex.Response :?> HttpWebResponse
                                                  let st = res.StatusCode
                                                  Some (int st, string st)
            | _ -> None
        with
        | _ -> None

    // Checks wether a given link is broken.
    let checkLink url = 
        let status = getStatus url
        match status with
        | Some x ->
            let a, b = x

            if a <> 200 then
                Some {Status = sprintf "%d %s" a b; Link = url}
            else
                None
        | None -> None

    /// Matches a pattern and returns the match value, count and index.
    let regex pattern html =
        let m = Regex(pattern).Matches(html)
        match m.Count with
        | 0 -> None
        | _ -> Some(m.[0].Groups.[1].Value , m.Count, Some m.[0].Index)

    let titlePat = "(?is)<title>(.*?)</title>"
    let descPat = "(?is)<meta\ +name=\"description\"\ +content=\"([^/\"]*)\""
    let h1Pat = "(?is)<h1>(.*?)</h1>"

    /// Detects the following violations:
    /// missing title tag,
    /// multiple title tags,
    /// empty title tag,
    /// title longer than 65 characters or shorter than 5 ones.
    let checkTitle (title : (string * int * int option) option) =
        async {
            let arr = 
                [|
                    match title with
                    | Some (_, var, idx) when var > 1 -> yield Some {
                                                                   Code = "TitleMultiple"
                                                                   Level = Warning
                                                                   Title = "The page contains multiple title tags."
                                                                   Index = idx
                                                                   Description = sprintf "The page markup contains %d <title> tags. The title tag must be unique within the head section." var
                                                                   Recommendation = "Remove the extra <title> tags."
                                                                   }

                    | Some ("", _, idx) -> yield Some {
                                                     Code = "TitleEmpty"
                                                     Level = Error
                                                     Title = "The title tag is empty."
                                                     Index = idx
                                                     Description = "An empty title tag affects the page's ranking negatively."
                                                     Recommendation = "Write an accurate descriptive title between 5 and 65 characters."
                                                     }

                    | Some (str, _, idx) when str.Length > 65 -> yield Some {
                                                                           Code = "TitleLong"
                                                                           Level = Warning
                                                                           Title = "The title might be too long."
                                                                           Index = idx
                                                                           Description = sprintf "The current title is %d characters long." str.Length
                                                                           Recommendation = "Reduce the length of the title to less than 65 characters (including spaces)."
                                                                           }

                    | Some (str, _, idx) when str.Length < 5 -> yield Some {
                                                                          Code = "TitleShort"
                                                                          Level = Warning
                                                                          Title = "The title might be too short."
                                                                          Index = idx
                                                                          Description = sprintf "The current title is %d characters long." str.Length
                                                                          Recommendation = "Add more text to better describe the page's content."
                                                                          }

                    | Some _ -> yield None

                    | None -> yield Some {
                                        Code = "TitleMissing"
                                        Level = Error
                                        Title = "The title tag is missing."
                                        Index = None
                                        Description = "A missing <title> tag negatively affects the ranking of a Web page."
                                        Recommendation = "Add a descriptive and accurate <title> tag inside the <head> section."
                                        }
                |]
            return arr
        }

    /// Checks wheter the title and the meta description tags have the same content.
    let checkTitleEqualsDesc (title : (string * int * int option) option) (desc : (string * int * int option) option) = 
        async {
            let arr = 
                [|
                    if title.IsSome && desc.IsSome then
                        let t, _, _ = title.Value
                        let d, _, _ = desc.Value
                        if t = d then
                            yield Some {
                                      Code = "TitleEqualsDescription"
                                      Level = Warning
                                      Title = "The title and descripion tags have identical content."
                                      Index = None
                                      Description = "The current description reproduces the title of the page."
                                      Recommendation = "Write a unique accurate description."
                                      }
                        else
                            yield None
                    else
                        yield None
                |]
            return arr
        }

    /// Detects the following violations:
    /// multiple meta description tags,
    /// empty meta description tag,
    /// description longer than 150 characters or shorter than 25 ones,
    /// missing meta description tag.
    let checkDesc (desc : (string * int * int option) option) =
        async {
            let arr = 
                [|
                    match desc with
                    | Some (_, var, idx) when var > 1 -> yield Some {
                                                                   Code = "DescMultiple"
                                                                   Level = Warning
                                                                   Title = "The page contains multiple description meta tags."
                                                                   Index = idx
                                                                   Description = sprintf "The page markup contains %d description meta tags." var
                                                                   Recommendation = "Use the meta description tag only once."
                                                                   }

                    | Some ("", _, idx) -> yield Some {
                                                     Code = "DescEmpty"
                                                     Level = Warning
                                                     Title = "The content attribute of the description meta tags is empty."
                                                     Index = idx
                                                     Description = "The description meta tag provides search engines with a summary of the page's content."
                                                     Recommendation = "Insert descriptive text inside the content attribute."
                                                     }

                    | Some (str, _, idx) when str.Length > 150 -> yield Some {
                                                                            Code = "DescLong"
                                                                            Level = Warning
                                                                            Title = "The description might be too long."
                                                                            Index = idx
                                                                            Description = sprintf "The current description is %d characters long." str.Length
                                                                            Recommendation = "Adjust the length of the description to keep it below 150 characters."
                                                                            }

                    | Some (str, _, idx) when str.Length < 25 -> yield Some {
                                                                           Code = "DescShort"
                                                                           Level = Warning
                                                                           Title = "The description might be too short."
                                                                           Index = idx
                                                                           Description = sprintf "The current description is %d characters long." str.Length
                                                                           Recommendation = "Adjust the length of the description to keep it between 25 and 150 characters."
                                                                           }

                    | Some _ -> yield None

                    | None -> yield Some {
                                        Code = "DescMissing"
                                        Level = Error
                                        Title = "The description meta tag is missing."
                                        Index = None
                                        Description = "The page markup doesn't contain a description meta tag."
                                        Recommendation = "Add a <meta name=\"description\" content=\"descriptionContent\" /> tag to the <head> section."
                                        }
                |]
            return arr
        }

    /// Detects the following violations:
    /// multiple h1 tags,
    /// empty h1 tag,
    /// missing h1 tag.
    let checkH1 (h1 : (string * int * int option) option) =
        async {
            let arr =
                [|
                    match h1 with
                    | Some (_, var, idx) when var > 1 -> yield Some {
                                                                   Code = "H1Multiple"
                                                                   Level = Warning
                                                                   Title = sprintf "The page contains %d <h1> tags." var
                                                                   Index = idx
                                                                   Description = "The <h1> tag describes what the page is about."
                                                                   Recommendation = "Use the <h1> tag once per page."
                                                                   }

                    | Some ("", _, idx) -> yield Some {
                                                     Code = "H1Empty"
                                                     Level = Warning
                                                     Title = "The <h1> tag is empty."
                                                     Index = idx
                                                     Description = "The <h1> tag describes what the page is about."
                                                     Recommendation = "Add keyword rich content to the <h1> tag."
                                                     }

                    | Some _ -> yield None

                    | None -> yield Some {
                                        Code = "H1Missing"
                                        Level = Warning
                                        Title = "The h1 tag is missing."
                                        Index = None
                                        Description = "The <h1> tag indicates what the page is about."
                                        Recommendation = "Add a descriptive heading."
                                        }
                |]
            return arr
        }

    /// Detects the following violations:
    /// large inline script code (> 2048 characters),
    /// large inline CSS definitions (> 1024 characters).
    let checInlineScriptCss html =
        async {
            let arr = 
                [|
                    let script =
                        [
                            for m in Regex("(?is)<script.*?</script>").Matches(html) do
                                yield m.Value, m.Index
                        ]
                        |> List.filter (fun (x, _) -> x.Length > 2048)
                        |> List.map (fun (x, y) -> Some {
                                                       Code = "LargeInlineScript"
                                                       Level = Warning
                                                       Title = sprintf "The page contains a large block of inline script code (%d characters)." x.Length
                                                       Index = Some y
                                                       Description = "Large imbedded script code might prevent search engines from indexing deeper useful content."
                                                       Recommendation = "Move inline script code to an external file."
                                                       })
                    let css = 
                        [
                            for m in Regex("(?is)<style.*?</style>").Matches(html) do
                                yield m.Value, m.Index
                        ]
                        |> List.filter (fun (x, _) -> x.Length > 1024)
                        |> List.map (fun (x, y) -> Some {
                                                       Code = "LargeInlineCSS"
                                                       Level = Warning
                                                       Title = sprintf "The page contains a large block of inline CSS definitions (%d characters)." x.Length
                                                       Index = Some y
                                                       Description = "Large imbedded CSS might prevent search engines from indexing deeper useful content."
                                                       Recommendation = "Move inline CSS code to an external style sheet."})
                    yield! script
                    yield! css
                |]
            return arr
        }

    /// Detects img tags that doesn't contain an alt attribute.
    let checkImages html =
        async {
            let imgPattern = "(?is)<img.+?>"
            let altPattern = "(?i)alt=\"[^\"]+\""
    //        let heightPattern = "(?i)height=\"\d+\""
    //        let widthPattern = "(?i)width=\"\d+\""

            let images = 
                [
                    for x in Regex(imgPattern).Matches(html) do
                        yield x.Value, x.Index
                ]

            let images' =
                [|   
                    for x, y in images do
                        let m = Regex(altPattern).IsMatch(x)
    //                    let height = Regex(heightPattern).IsMatch(fst x)
    //                    let width = Regex(widthPattern).IsMatch(fst x)
                        match m with
                        | false -> yield Some {
                                             Code = "AltMissing"
                                             Level = Warning
                                             Title = "The <img> tag doesn't contain an alt attribute."
                                             Index = Some y
                                             Description = "The alt attribute describes the content of the image."
                                             Recommendation = "Add a descriptive alt attribute."
                                             }
                        | true -> yield None
    //                    match height with
    //                    | false -> yield Some {Code="HeightMissing"; Level=Warning; Title="The height attribute is missing."; Index=snd x; Description=""; Recommendation=""}
    //                    | true -> yield None
    //                    match width with
    //                    | false -> yield Some {Code="WidthMissing"; Level=Warning; Title="The width attribute is missing."; Index=snd x; Description=""; Recommendation=""}
    //                    | true -> yield None
                |]
            return images'
        }

open Helpers

/// Detects HTML related SEO violations.
let checkHtml html =
    let title = regex titlePat html
    let desc = regex descPat html
    let h1 = regex h1Pat html
    let violations =
        [
            checkTitle title
            checkTitleEqualsDesc title desc
            checkDesc desc
            checkH1 h1
            checkImages html
            checInlineScriptCss html
        ]
        |> Async.Parallel
        |> Async.RunSynchronously
        |> Array.concat
        |> Array.filter (fun v -> v.IsSome)
    violations

/// Validates a URI against the W3C validator.
let validateMarkup (uri : Uri) =
    async {
        let url = "http://validator.w3.org/check?uri=" + string uri + "&output=soap12"
        let doc = XDocument.Load url
        let descendants = doc.Descendants()
        let valid = descendants |> Seq.find (fun x -> x.Name.LocalName = "validity")
        match valid.Value with
        | "false" -> let errors = descendants |> Seq.filter (fun x -> x.Name.LocalName = "error")
                     let errors' =
                         [|
                             for x in errors do
                                 let elems = x.Descendants()
                                 let line = elems |> Seq.find (fun x -> x.Name.LocalName = "line")
                                 let col = elems |> Seq.find (fun x -> x.Name.LocalName = "col")
                                 let msg = elems |> Seq.find (fun x -> x.Name.LocalName = "message")
                                 yield {Level = "Error"; Line = line.Value; Col = col.Value; Message = msg.Value }
                         |]

                     let warnings = descendants |> Seq.filter (fun x -> x.Name.LocalName = "warning")
                     let warnings' = 
                         [|
                             for x in warnings do
                                 let elems = x.Descendants()
                                 let line =
                                     try
                                         (elems |> Seq.find (fun x -> x.Name.LocalName = "line")).Value
                                     with
                                     | _ -> ""
                                 let col = 
                                     try
                                         (elems |> Seq.find (fun x -> x.Name.LocalName = "col")).Value
                                     with
                                     | _ -> ""
                                 let msg = elems |> Seq.find (fun x -> x.Name.LocalName = "message")
                                 yield {Level = "Warning"; Line = line; Col = col; Message = msg.Value}
                         |]
                     return Array.append errors' warnings'
        | _ -> return [||]          
    }

/// Checks broken links.
let checkBrokenLinks links context =
    let q = ConcurrentQueue<string>()
    let q' = ConcurrentQueue<BrokenLink>()
    links |> List.iter (fun x -> q.Enqueue x)

//    let t = true
//    let f = false

    let supervisor =
        MailboxProcessor.Start( fun x -> 
            let rec loop (cq : ConcurrentQueue<string>) (run : bool) =
                async {
                    let! msg = x.Receive()
                    match msg with
                    | Mailbox mailbox -> 
                        if run then
                            let url  = cq.TryDequeue()
                            match url with
                            | true, url -> mailbox.Post(Url <| Some url)
                            | _ -> mailbox.Post Stop
                            return! loop cq run
                        else 
                            mailbox.Post Stop
                            return! loop cq run

                    | Stop -> 
                        return! loop cq false

                    | _ -> 
                        (x :> IDisposable).Dispose()
                        let arr =
                            [|
                                for x in q' do
                                    yield x
                            |]
                        match arr.Length with
                        | 0 -> 
                            do! Async.SwitchToContext context
                            MessageBox.Show("There are no broken links.") |> ignore
                        | _ -> 
                            do! Async.SwitchToContext context
                            displayBrokenLinks arr
                }
            loop q true)   

    let urlCollector =
        MailboxProcessor.Start(fun y ->
            let rec loop count =
                async {
                    let! msg = y.TryReceive(8000)
                    match msg with
                    | Some message ->
                        match message with
                        | BLink url ->
                            q'.Enqueue url
                            return! loop count
                        | _ ->
                            match count with
                            | Gate -> supervisor.Post Done
                                      (y :> IDisposable).Dispose()
                            | _ -> return! loop (count + 1)
                    | None -> supervisor.Post Stop
                              return! loop count
                }
            loop 1)

    let linkChecker id =
        MailboxProcessor.Start(fun inbox ->
            let rec loop() =
                async {
                    let! msg = inbox.Receive()
                    match msg with
                    | Url u -> 
                        match u with
                        | Some url ->
                            let status = checkLink url
                            if status.IsSome then
                                urlCollector.Post <| BLink status.Value
                            supervisor.Post(Mailbox(inbox))
                            return! loop()
                        | None -> supervisor.Post(Mailbox(inbox))
                                  return! loop()
                    | _ -> urlCollector.Post Done
                           (inbox :> IDisposable).Dispose()
                }
            loop())

    let agents =
        [
            for i in 1 .. Gate do
                yield linkChecker i
        ]
    
    agents |> List.iter (fun ag -> ag.Post(Url None))